home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 August: Tool Chest / Dev.CD Aug 94.toast / Tool Chest / Development Platforms / Macintosh Common Lisp Related / User Contributions / processes.lisp < prev    next >
Encoding:
Text File  |  1994-06-22  |  4.5 KB  |  131 lines  |  [TEXT/CCL2]
  1. ; processes.lisp
  2. ;
  3. ; Enough process stuff to select AppleLink and get back with the keyboard
  4.  
  5. (in-package :ccl)
  6.  
  7. (defmacro with-processInfoRec (sym &body body)
  8.   (let ((name (gensym))
  9.         (fsspec (gensym)))
  10.     `(rlet ((,sym :ProcessInfoRec)
  11.             (,name (string 32))
  12.             (,fsSpec :FSSpec))
  13.        (setf (pref ,sym processInfoRec.processInfoLength) (record-length :processInfoRec)
  14.              (pref ,sym processInfoRec.processName) ,name
  15.              (pref ,sym processInfoRec.processAppSpec) ,fsSpec)
  16.        ,@body)))  
  17.  
  18. (defun launch-application (filename)
  19.   (rlet ((fsspec :FSSpec))
  20.     (rlet ((pb :launchParamBlockRec
  21.                :launchBlockID #$extendedBlock
  22.                :launchEPBLength #$extendedBlockLen
  23.                :launchControlFlags (+ #$launchContinue #$launchNoFileFlags)
  24.                :launchAppSpec fsspec
  25.                :launchAppParameters (%null-ptr)))
  26.       (with-pstrs ((name (mac-namestring (probe-file filename))))
  27.         (#_FSMakeFSSpec 0 0 name fsspec))
  28.       (when (eql 0 (#_LaunchApplication pb))
  29.         filename))))
  30.  
  31. ; Given a four-character creator code, finds the most recent application.
  32. ; Searches the mounted devices in the order mounted (same as the Finder?)
  33. ; until it finds one.
  34. (defun get-creator-path (creator)
  35.   (let ((devs (directory "*:")))
  36.     (dolist (vrefnum (sort (mapcar 'volume-number devs) #'>))
  37.       (rlet ((pb :DTPBRec
  38.                  :ioNamePtr (%null-ptr)
  39.                  :ioVRefnum vrefnum)
  40.              (fsspec :fsspec))
  41.         (when (eql 0 (#_PBDTGetPath pb))
  42.           (setf (rref pb :DTPBRec.ioNamePtr)
  43.                 (%inc-ptr fsspec (get-field-offset :fsspec.name))
  44.                 (pref pb :DTPBRec.ioIndex) 0
  45.                 (pref pb :DTPBRec.ioFileCreator) creator)
  46.           (when (eql 0 (#_PBDTGetAPPL pb))
  47.             (setf (pref fsspec :fsspec.vRefnum) vrefnum
  48.                   (pref fsspec :fsspec.parID) (pref pb :DTPBRec.ioAPPLParID))
  49.             (return (%path-from-fsspec fsspec))))))))
  50.                                
  51. (defun launch-creator (creator)
  52.   (let ((file (get-creator-path creator)))
  53.     (when file
  54.       (launch-application file))))
  55.  
  56. ; From IM VI p. 29-11
  57. (defun find-process (signature &optional psn)
  58.   (unless psn (setq psn  (make-record :processSerialNumber)))
  59.   (with-processInfoRec infoRec
  60.     (setf (pref psn :processSerialNumber.highLongOfPSN) 0
  61.           (pref psn :processSerialNumber.lowLongOfPSN) 0)
  62.     (loop
  63.       (unless (eql (#_GetNextProcess psn) #$noErr) (return nil))
  64.       (when (and (eql (#_getProcessInformation psn infoRec) #$noErr)
  65.                  (%equal-ostype infoRec :APPL
  66.                                 (get-field-offset :processInfoRec.processType))
  67.                  (%equal-ostype infoRec signature
  68.                                 (get-field-offset :processInfoRec.processSignature)))
  69.         (return psn)))))
  70.                  
  71. (defun select-process (creator &optional (launch? t))
  72.   (rlet ((psn :processSerialNumber))
  73.     (if (find-process creator psn)
  74.       (#_setFrontProcess psn)
  75.       (unless (and launch? (launch-creator creator))
  76.         (ed-beep)))))
  77.  
  78. (defun select-applelink (&optional ignore)
  79.   (declare (ignore ignore))
  80.   (select-process :GEOL))
  81.  
  82. (def-fred-command (:control :shift #\A) select-applelink)
  83.  
  84. (defun select-macx (&optional ignore)
  85.   (declare (ignore ignore))
  86.   (select-process :|MacX|))
  87. (def-fred-command (:control :shift #\X) select-macx)
  88.  
  89. (defun select-techmail (&optional ignore)
  90.   (declare (ignore ignore))
  91.   (select-process :MITM))
  92. (def-fred-command (:control :shift #\T) select-techmail)
  93.  
  94. (defun select-Eudora (&optional ignore)
  95.   (declare (ignore ignore))
  96.   (select-process :|CSOm|))
  97. (def-fred-command (:control :shift #\E) select-eudora)
  98.  
  99. (defun select-macterminal (&optional ignore)
  100.   (declare (ignore ignore))
  101.   (select-process :|Term|))
  102. (def-fred-command (:control :shift #\M) select-macterminal)
  103.  
  104. (defun select-zterm (&optional ignore)
  105.   (declare (ignore ignore))
  106.   (select-process :\zTRM))
  107. (def-fred-command (:control :shift #\Z) select-zterm)
  108.  
  109. (defun select-msword (&optional ignore)
  110.   (declare (ignore ignore))
  111.   (select-process :MSWD))
  112. (def-fred-command (:control :shift #\W) select-msword)
  113.  
  114. (defun select-mcl ()
  115.   (rlet ((psn :processSerialNumber))
  116.     (#_getCurrentProcess psn)
  117.     (#_setFrontProcess psn)))
  118.  
  119. (defun select-mcl-eventhook (&rest ignore)
  120.   (declare (ignore ignore))
  121.   (unless *foreground*
  122.     (let ((*current-event* nil))
  123.       (makunbound '*current-event*)
  124.       (when (and (control-key-p) (option-key-p) (command-key-p))
  125.         (select-mcl))))
  126.   nil)
  127.  
  128. (push 'select-mcl-eventhook *eventhook*)
  129.  
  130. (provide :processes)
  131.